home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / rand.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  4.2 KB  |  120 lines
  1. ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: rand.lisp,v 1.4 91/12/14 09:01:01 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Functions to random number functions for Spice Lisp 
  15. ;;; Written by David Adam.
  16. ;;;
  17. ;;; The random number functions are part of the standard Spicelisp environment.
  18. ;;;
  19. ;;; **********************************************************************
  20. ;;;
  21. (in-package 'lisp)
  22. (export '(random-state random-state-p random *random-state*
  23.       make-random-state))
  24.  
  25. (defconstant random-const-a 8373)
  26. (defconstant random-const-c 101010101)
  27. (defconstant random-upper-bound (1- most-positive-fixnum))
  28. (defconstant random-max 54)
  29. (defconstant %fixnum-length (integer-length most-positive-fixnum))
  30. (defvar rand-seed 0)
  31.  
  32. (defstruct (random-state
  33.         (:constructor make-random-object)
  34.         (:make-load-form-fun :just-dump-it-normally))
  35.   (j 24 :type integer)
  36.   (k 0 :type integer)
  37.   (seed (make-array (1+ random-max) :initial-contents
  38.             (do ((list-rands () (cons (rand1) list-rands))
  39.              (i 0 (1+ i)))
  40.             ((> i random-max) list-rands)))
  41.     :type simple-vector))
  42.  
  43.  
  44. ;;; Generates a random number from rand-seed.
  45. (defun rand1 ()
  46.    (setq rand-seed (mod (+ (* rand-seed random-const-a) random-const-c)
  47.             (1+ random-upper-bound))))
  48.  
  49.  
  50. (defvar *random-state* (make-random-object))
  51.  
  52.  
  53. ;;; rand3  --  Internal
  54. ;;;
  55. ;;; This function generates fixnums between 0 and random-upper-bound, 
  56. ;;; inclusive For the algorithm to work random-upper-bound must be an 
  57. ;;; even positive fixnum.  State is the random state to use.
  58. ;;;
  59. (defun rand3 (state)
  60.   (let ((seed (random-state-seed state))
  61.     (j (random-state-j state))
  62.     (k (random-state-k state)))
  63.     (declare (fixnum j k) (simple-vector seed))
  64.     (setf (svref seed k)
  65.       (let ((a (- random-upper-bound
  66.               (svref seed
  67.                   (setf (random-state-j state)
  68.                     (if (= j 0) random-max (1- j))))
  69.               (svref seed
  70.                   (setf (random-state-k state)
  71.                     (if (= k 0) random-max (1- k)))))))
  72.         (if (minusp a) (- a) (- random-upper-bound a))))))
  73.  
  74.  
  75. (defun copy-state (cur-state)
  76.   (let ((state (make-random-object
  77.         :seed (make-array 55)
  78.         :j (random-state-j cur-state)
  79.         :k (random-state-k cur-state))))
  80.     (do ((i 0 (1+ i)))
  81.     ((= i 55) state)
  82.       (declare (fixnum i))
  83.       (setf (aref (random-state-seed  state) i)
  84.         (aref (random-state-seed cur-state) i)))))
  85.  
  86. (defun make-random-state (&optional state)
  87.   "Make a random state object.  If State is not supplied, return a copy
  88.   of the default random state.  If State is a random state, then return a
  89.   copy of it.  If state is T then return a random state generated from
  90.   the universal time."
  91.   (cond ((not state) (copy-state *random-state*))
  92.     ((random-state-p state) (copy-state state))
  93.     ((eq state t) (setq rand-seed (get-universal-time))
  94.               (make-random-object))
  95.     (t (error "Bad argument, ~A, for RANDOM-STATE." state))))
  96.  
  97. (proclaim '(ftype (function (t) fixnum) rand3))
  98. (defun random (arg &optional (state *random-state*))
  99.   "Generate a uniformly distributed pseudo-random number between zero
  100.   and Arg.  State, if supplied, is the random state to use."
  101.   (typecase arg
  102.     (fixnum
  103.      (unless (plusp (the fixnum arg))
  104.        (error "Non-positive argument, ~A, to RANDOM." arg))     
  105.      (rem (the fixnum (rand3 state)) (the fixnum arg)))
  106.     (float
  107.      (unless (plusp arg)
  108.        (error "Non-positive argument, ~A, to RANDOM." arg))
  109.      (let ((arg-length (float-digits arg)))
  110.        (* arg (/ (float (random (ash 2 arg-length) state))
  111.          (float (ash 2 arg-length))))))
  112.     (integer
  113.      (unless (plusp arg)
  114.        (error "Non-positive argument, ~A, to RANDOM." arg))
  115.      (do ((tot (rand3 state) (+ (ash tot %fixnum-length) (rand3 state)))
  116.       (end (ash arg (- %fixnum-length))
  117.            (ash end (- %fixnum-length))))
  118.      ((zerop end) (mod tot arg))))
  119.     (t (error "Wrong type argument, ~A, to RANDOM." arg))))
  120.